home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / trace.scm < prev    next >
Text File  |  1999-04-19  |  4KB  |  111 lines
  1. ;;;; "trace.scm" Utility macros for tracing in Scheme.
  2. ;;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'qp)                ;for the qp printer.
  21. (define debug:indent 0)
  22.  
  23. (define debug:tracef
  24.   (let ((null? null?)            ;These bindings are so that
  25.     (not not)            ;tracef will not trace parts
  26.     (car car) (cdr cdr)        ;of itself.
  27.     (eq? eq?) (+ +) (zero? zero?) (modulo modulo)
  28.     (apply apply) (display display) (qpn qpn)
  29.  
  30.     (CALL (string->symbol "CALL"))
  31.     (RETN (string->symbol "RETN")))
  32.     (lambda (function . optname)
  33.       (set! debug:indent 0)
  34.       (let ((name (if (null? optname) function (car optname))))
  35.     (lambda args
  36.       (cond ((and (not (null? args))
  37.               (eq? (car args) 'debug:untrace-object)
  38.               (null? (cdr args)))
  39.          function)
  40.         (else
  41.          (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
  42.          (apply qpn CALL name args)
  43.          (set! debug:indent (modulo (+ 1 debug:indent) 16))
  44.          (let ((ans (apply function args)))
  45.            (set! debug:indent (modulo (+ -1 debug:indent) 16))
  46.            (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
  47.            (qpn RETN name ans)
  48.            ans))))))))
  49.  
  50. ;;; the reason I use a symbol for debug:untrace-object is so
  51. ;;; that functions can still be untraced if this file is read in twice.
  52.  
  53. (define (debug:untracef function)
  54.   (set! debug:indent 0)
  55.   (function 'debug:untrace-object))
  56.  
  57. ;;;;The trace: functions wrap around the debug: functions to provide
  58. ;;; niceties like keeping track of traced functions and dealing with
  59. ;;; redefinition.
  60.  
  61. (require 'alist)
  62. (define trace:adder (alist-associator eq?))
  63. (define trace:deler (alist-remover eq?))
  64.  
  65. (define *traced-procedures* '())
  66. (define (trace:tracef fun sym)
  67.   (cond ((not (procedure? fun))
  68.      (display "WARNING: not a procedure " (current-error-port))
  69.      (display sym (current-error-port))
  70.      (newline (current-error-port))
  71.      (set! *traced-procedures* (trace:deler *traced-procedures* sym))
  72.      fun)
  73.     (else
  74.      (let ((p (assq sym *traced-procedures*)))
  75.        (cond ((and p (eq? (cdr p) fun))
  76.           fun)
  77.          (else
  78.           (let ((tfun (debug:tracef fun sym)))
  79.             (set! *traced-procedures*
  80.               (trace:adder *traced-procedures* sym tfun))
  81.             tfun)))))))
  82.  
  83. (define (trace:untracef fun sym)
  84.   (let ((p (assq sym *traced-procedures*)))
  85.     (set! *traced-procedures* (trace:deler *traced-procedures* sym))
  86.     (cond ((not (procedure? fun)) fun)
  87.       ((not p) fun)
  88.       ((eq? (cdr p) fun)
  89.        (debug:untracef fun))
  90.       (else fun))))
  91.  
  92. (define tracef debug:tracef)
  93. (define untracef debug:untracef)
  94.  
  95. ;;;; Finally, the macros trace and untrace
  96.  
  97. (defmacro trace xs
  98.   (if (null? xs)
  99.       `(begin (set! debug:indent 0)
  100.           ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x)))
  101.              (map car *traced-procedures*))
  102.           (map car *traced-procedures*))
  103.       `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) xs))))
  104. (defmacro untrace xs
  105.   (if (null? xs)
  106.       (slib:eval
  107.        `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x)))
  108.               (map car *traced-procedures*))
  109.            '',(map car *traced-procedures*)))
  110.       `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x))) xs))))
  111.